HPAVC

home *** CD-ROM | disk | FTP | other *** search

/ HPAVC / HPAVC CD-ROM.iso / pc / SWAG9708.ZIP / XX3402.ZIP / XX34SRC.ZIP / XX3402.PAS < prev

Wrap

Pascal/Delphi Source File | 1994-01-28 | 68.9 KB | 1,826 lines

(******************************************************************************) (* *) (* TITLE : XX3402 ver 0.2 *) (* *) (* AUTHOR : Guy McLoughlin *) (* *) (* DATE : January 28, 1994 *) (* *) (* PURPOSE : Modified XX encoder/decoder. *) (* *) (* NOTES : XX3402.PAS source-code released to the public domain. *) (* This source-code requires Edwin T. Floyd's public domain *) (* (see author's notes) CRC.PAS unit to compile. *) (* *) (******************************************************************************) (* Compiler directives. *) {$I COMP.SET} {$M 4096, 32768, 131072} program Xx3402; uses dos, crc; (********************** START OF GLOBAL DATA DEFINITIONS **********************) type T_Ch2 = array[1..2] of char; T_Ch3 = array[1..3] of char; T_Ch4 = array[1..4] of char; T_Ch5 = array[1..5] of char; T_Ch6 = array[1..6] of char; T_Ch7 = array[1..7] of char; T_Ch8 = array[1..8] of char; T_Ch10 = array[1..10] of char; T_Ch12 = array[1..12] of char; T_Ch14 = array[1..14] of char; T_Ch27 = array[1..27] of char; T_Ch62 = array[1..62] of char; T_Ch64 = array[0..63] of char; T_By256 = array[0..255] of byte; T_Wo255 = array[1..255] of word; T_Lo255 = array[1..255] of longint; T_St2 = string[2]; T_St3 = string[3]; T_St8 = string[8]; T_St12 = string[12]; T_St20 = string[20]; T_3Ch2 = array[1..3] of T_Ch2; T_By80 = array[43..122] of byte; T_Header1 = T_Ch62; T_Header2 = record Spacer0 : T_Ch8; Size : T_Ch6; Spacer1 : char; Fday : T_Ch2; Fmonth : T_Ch2; Fyear : T_Ch2; Spacer2 : char; FCols : T_Ch3; Spacer3 : char; FRows : T_Ch3; Spacer4 : char; CrcValue : T_Ch5; Spacer5 : char; HexFlag : char; Spacer6 : T_Ch2; FName : T_Ch12; Block : T_Ch3; Spacer7 : T_Ch3; BlockTot : T_Ch3; Spacer8 : T_Ch2; end; const co_MaxBuffSize = 65520; type T_EncBuff = array[1..co_MaxBuffSize] of char; T_EncBuffPtr = ^T_EncBuff; T_BinBuff = array[1..((co_MaxBuffSize div 4) * 3)] of byte; T_BinBuffPtr = ^T_BinBuff; (******************************** CONSTANTS ***********************************) const (* Column, row default size. *) co_ColDef = 72; co_RowDef = 85; (* Minimum and maximum column size. *) co_MinCol = 60; co_MaxCol = 100; (* Minimum and maximum row size. *) co_MinRow = 10; co_MaxRow = 600; (* Encoded block maximum. *) co_BlockMax = 255; (* Size of encoded header. *) co_HeaderSize = sizeof(T_Header1); (* File date constants. *) co_ThisCentury = 1900; co_NextCentury = 2000; (* Numeric error constant. *) co_NumError = -1111111111; (* Maximum encodeable binary file size in bytes. *) co_MaxFilesize = 11455875; (* Keypress constants. *) co_EnterKey = #13; co_BackSpaceKey = #8; (************************* PRE-INITIALIZED VARIABLES **************************) (* Encoding boolean flag. *) bo_Encoding : boolean = false; (* Test-mode boolean flag. *) bo_TestMode : boolean = false; (* Split encoded output flag. *) bo_SplitOutput : boolean = false; (* Erase corrupt output file flag. *) bo_EraseOutFile : boolean = false; (* Carriage-return and line-feed constants. *) co_CrLf : T_Ch2 = #13#10; co_CrLf2 : T_Ch4 = #13#10#13#10; (* Initial encoded block delimiter. *) co_XxBlockID : T_Ch7 = '*XX3402'; (* Alternative delimiter character set. *) co_AltDelSet : array[0..9] of char = '*:#@=$?%&!'; (* Alternative delimiter look-up string. *) co_AltDelStr : T_Ch27 = 'AD1AD2AD3AD4AD5AD6AD7AD8AD9'; (* Encoded block end marker constants. *) co_EndMark1 : T_Ch5 = '*****'; co_EndMark2 : T_Ch14 = ' END OF BLOCK '; (* Encoded block header constant. *) co_Header1 : T_Header1 = '*XX3402-000000-000000--72--85-00000------------.-------OF---' + #13#10; (* Standard XX encoding character array. *) co_XxChar1 : T_Ch64 = '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; (* Standard XX encoding character set. *) co_XxChar2 : set of char = ['+','-','0'..'9','A'..'Z','a'..'z']; (* Translation table for encoded characters. *) co_BinTable : T_By80 = ( 0, 0, 1, 0, 0, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 0, 0, 0, 0, 0, 0, 0, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 0, 0, 0, 0, 0, 0, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63); (* First parameter look-up string. *) co_Params1 : T_Ch10 = 'eEdDestTES'; (* Hexidecimal character array. *) co_HexChars : array[0..15] of char = '0123456789ABCDEF'; (* Set of valid DOS filename characters. *) se_FNameChars : set of char = [#33, #35..#41, #45, '0'..'9', '@'..'Z', '^'..'{', '}', '~']; (********************** END OF GLOBAL DATA DEFINITIONS ************************) (***** Convert BYTE to HEX string. *) (* *) function Byte2Hex({input } by_IN : byte) : {output} T_St2; begin Byte2Hex[0] := #2; Byte2Hex[1] := co_HexChars[(by_IN SHR 4)]; Byte2Hex[2] := co_HexChars[(by_IN AND $F)] end; (* Byte2Hex. *) (***** Convert LONGINT to HEX string. *) (* *) function Long2Hex({input } lo_IN : longint) : {output} T_St8; var by_4 : array[1..4] of byte absolute lo_IN; begin Long2Hex[0] := #8; Long2Hex[1] := co_HexChars[(by_4[4] SHR 4)]; Long2Hex[2] := co_HexChars[(by_4[4] AND $F)]; Long2Hex[3] := co_HexChars[(by_4[3] SHR 4)]; Long2Hex[4] := co_HexChars[(by_4[3] AND $F)]; Long2Hex[5] := co_HexChars[(by_4[2] SHR 4)]; Long2Hex[6] := co_HexChars[(by_4[2] AND $F)]; Long2Hex[7] := co_HexChars[(by_4[1] SHR 4)]; Long2Hex[8] := co_HexChars[(by_4[1] AND $F)] end; (* Long2Hex. *) (***** Search data buffer with TP's POS function. *) (* *) function PosSearch({input } var Buffer; wo_BuffSize : word; st_Pattern : string) : {output} word; type T_Wo2 = array[1..2] of word; T_Ch255 = array[1..255] of char; var po_Buffer : ^T_Ch255; by_Pos, by_IncSize, by_PredSize : byte; wo_Index : word; begin (* Initialize variables. *) wo_Index := 0; po_Buffer := addr(Buffer); by_PredSize := pred(length(st_Pattern)); by_IncSize := (255 - by_PredSize); (* Repeat..Until "pattern" found, or buffer completely searched *) repeat (* Search for "pattern" string. *) by_Pos := pos(st_Pattern, po_Buffer^); (* If "pattern" not found, then advance pointer address. *) if (by_Pos = 0) then begin inc(wo_Index, by_IncSize); inc(T_Wo2(po_Buffer)[1], by_IncSize); (* Normalize pointer. *) inc(T_Wo2(po_Buffer)[2], (T_Wo2(po_Buffer)[1] SHR 4)); T_Wo2(po_Buffer)[1] := (T_Wo2(po_Buffer)[1] MOD $10) end else (* Else "pattern" was found, advance index variable. *) inc(wo_Index, by_Pos) until (by_Pos <> 0) OR (wo_Index > wo_BuffSize); (* If "pattern" not found, then... *) if (by_Pos = 0) OR (wo_Index > (wo_BuffSize - by_PredSize)) then PosSearch := 0 else (* Else "pattern" was found. *) PosSearch := wo_Index end; (* PosSearch. *) (***** Convert a numerical string to a LONGINT. *) (* *) function Str2Long({input } st_IN : T_St20; bo_HexNum : boolean) : {output} longint; var in_Error : integer; lo_Temp : longint; begin while (pos('-', st_IN) <> 0) do delete(st_IN, pos('-', st_IN), 1); if bo_HexNum then st_IN := '$' + st_IN; val(st_IN, lo_Temp, in_Error); if (in_Error <> 0) then Str2Long := co_NumError else Str2Long := lo_Temp end; (* Str2Long. *) const (* Hexidecimal-mode boolean flag. *) bo_HexMode : boolean = false; (***** Convert a WORD to numerical character string. *) (* *) procedure Word2Char1({input } wo_IN : word; {output} var ch_OUT); var by_Temp : byte; st_Temp : string[6]; begin if bo_HexMode then begin st_Temp := Byte2Hex(lo(wo_IN)); by_Temp := 1; while (st_Temp[by_Temp] = '0') do begin delete(st_Temp, by_Temp, 1); inc(by_Temp) end end else str(wo_IN, st_Temp); by_Temp := succ(length(st_Temp)); fillchar(st_Temp[by_Temp], (sizeof(st_Temp) - by_Temp), #32); move(st_Temp[1], ch_OUT, 2) end; (* Word2Char1. *) (***** Convert a WORD to numerical character string. *) (* *) procedure Word2Char2({input } wo_IN : word; {output} var ch_OUT); var by_Temp : byte; st_Temp : string[6]; begin if bo_HexMode then begin st_Temp := Byte2Hex(lo(wo_IN)); by_Temp := 1; while (st_Temp[by_Temp] = '0') do begin st_Temp[by_Temp] := '-'; inc(by_Temp) end end else str(wo_IN, st_Temp); while (length(st_Temp) < 3) do st_Temp := '-' + st_Temp; move(st_Temp[1], ch_OUT, 3) end; (* Word2Char2. *) (***** Convert a LONGINT to a numerical character string. *) (* *) procedure Long2Str({input } lo_IN : longint; by_Size : byte; {update} var Data); var st_Temp : T_St12; begin str(lo_IN, st_Temp); while (length(st_Temp) < by_Size) do st_Temp := '0' + st_Temp; move(st_Temp[1], Data, by_Size) end; (* Long2Str. *) (***** Convert a string to uppercase chars. *) (* *) function UpStr({input } st_IN : string) : {output} string; var by_Index : byte; begin for by_Index := 1 to length(st_IN) do st_IN[by_Index] := upcase(st_IN[by_Index]); UpStr := st_IN end; (* UpStr. *) (***** Function to indicate if a key-press is in the keyboard buffer. *) (* *) function KeyPressed : {output} boolean; assembler; asm mov ah, 01h int 16h mov ax, 00h jz @1 inc ax @1: end; (* KeyPressed. *) (***** Read a key-press. *) (* *) function ReadKey: {output} char; assembler; asm mov ah, 00h int 16h end; (* ReadKey. *) (***** Obtain Yes/No/Rename response from user. *) (* *) function YesNoRename : {output} char; var ch_Key : char; begin while KeyPressed do ch_Key := ReadKey; if bo_Encoding then repeat ch_Key := upcase(ReadKey) until(ch_Key in ['N','Y']) else repeat ch_Key := upcase(ReadKey) until(ch_Key in ['N','R','Y']); writeln(ch_Key); YesNoRename := ch_Key end; (* YesNoRename. *) (***** Obtain a valid filename from end user. *) (* *) function EnterFileName : T_St12; var by_DotPos, by_CharIndex : byte; bo_EntryOK, bo_BackSpace : boolean; ch_Key : char; st_Name : T_St12; begin by_CharIndex := 1; by_DotPos := 0; st_Name := ''; repeat bo_EntryOK := false; bo_BackSpace := false; ch_Key := upcase(readkey); if ch_Key IN se_FNameChars then bo_EntryOK := true else case ch_Key of '.' : if (by_CharIndex > 1) and (by_DotPos = 0) then by_CharIndex := 9; co_BackSpaceKey : bo_BackSpace := true end; if bo_BackSpace and (by_CharIndex > 1) then begin if by_DotPos > 0 then dec(by_DotPos); if (by_DotPos = 0) then by_CharIndex := length(st_Name) else dec(by_CharIndex); dec(st_Name[0]); write(co_BackSpaceKey, ' ', co_BackSpaceKey) end else if (by_CharIndex = 9) and (ch_Key <> co_EnterKey) then begin bo_EntryOK := true; ch_Key := '.'; inc(by_DotPos) end; if bo_EntryOK and (by_CharIndex < 13) then begin st_Name := st_Name + ch_Key; write(ch_Key); if (by_CharIndex > 9) then inc(by_DotPos); inc(by_CharIndex) end until (ch_Key = co_EnterKey) and (st_Name <> ''); EnterFileName := st_Name end; (* EnterFilename. *) (****** Calculate a 16-bit CRC check for the data buffer. *) (* *) function CalcCRC16({input } var Data; wo_DataSize : word) {output} : word; var wo_CRC : word; begin wo_CRC := 0; wo_CRC := UpdateCrc16(wo_CRC, Data, wo_DataSize); CalcCRC16 := wo_CRC end; (* CalcCRC16. *) (***** Display program syntax. *) (* *) procedure Syntax; begin writeln; writeln(' XX3402 Binary Encoder/Decoder Version 0.2 01-28-94'); writeln(' Public-Domain Utility by Guy McLoughlin '); writeln; writeln(' Usage: XX3402 <E|ES|D|T> [d:][path]<filename> [cols] [rows] [ADn]'); writeln; writeln(' Encode Parameters'); writeln(' <E> Encode binary file (single output file)'); writeln(' <ES> Encode binary file (split output files)'); writeln(' [cols] Min = 60, Max = 100 (default = 72)'); writeln(' [rows] Min = 10, Max = 600 (default = 85)'); writeln(' [ADn] Alternative delimiter (n = 1..9)'); writeln; writeln(' Decode Parameters'); writeln(' <D> Decode encoded file (Halt on any error )'); writeln(' <T> Test encoded blocks (Test for CRC errors)'); writeln; writeln(' Examples'); writeln(' XX3402 E MYFILE.ZIP (Encode MYFILE.ZIP, using defaults )'); writeln(' XX3402 ES MYFILE.ZIP (Encode MYFILE.ZIP, split output )'); writeln(' XX3402 D MYFILE.XX (Decode MYFILE.XX, using defaults )'); writeln(' XX3402 T MYFILE.XX (Test MYFILE.XX, display results)'); halt(0) end; (* Syntax. *) (***** Set alternative delimiter. *) (* *) procedure SetAltDel({input} ch_AD : char); begin co_XxBlockID[1] := ch_AD; co_Header1[1] := ch_AD; fillchar(co_EndMark1, sizeof(co_EndMark1), ch_AD) end; (* SetAltDel. *) var st_DirIN : dirstr; st_NameIN : namestr; st_ExtIN : extstr; wo_EncRowSize : word; wo_EncColSize : word; co_Header2 : T_Header2 absolute co_Header1; (***** Process the command-line parameters. *) (* *) procedure ProcessParams; begin (* If too many or too few parameters, then display syntax. *) if (paramcount > 5) OR (paramcount < 2) then Syntax; (* Process first parameter. *) case pos(paramstr(1), co_Params1) of 1, 2 : bo_Encoding := true; (* 'e' or 'E' *) 3, 4 :; (* 'd' or 'D' *) 7, 8 : bo_TestMode := true; (* 't' or 'T' *) 5, 9 : begin (* 'es' or 'ES' *) bo_Encoding := true; bo_SplitOutput := true end else Syntax end; (* Assign the name of the input file. *) fsplit(fexpand(paramstr(2)), st_DirIN, st_NameIN, st_ExtIN); (* If we are encoding binary data, then... *) if bo_Encoding then begin (* Set encoded column size. *) if (paramcount > 2) then begin wo_EncColSize := Str2Long(paramstr(3), false); (* Force size to a multiple of 4. *) wo_EncColSize := (wo_EncColSize SHR 2) SHL 2; (* If column size is too small or too big, use default size. *) If (wo_EncColSize < co_MinCol) OR (wo_EncColSize > co_MaxCol) then wo_EncColSize := co_ColDef; (* Assign column size to the encoded block header. *) Word2Char2(wo_EncColSize, co_Header2.FCols) end else wo_EncColSize := co_ColDef; (* Set encoded block row size. *) if (paramcount > 3) then begin wo_EncRowSize := Str2Long(paramstr(4), false); (* If row size is too small or too big, use default size. *) If (wo_EncRowSize < co_MinRow) OR (wo_EncRowSize > co_MaxRow) then wo_EncRowSize := co_RowDef; (* Assign row size to the encoded block header. *) Word2Char2(wo_EncRowSize, co_Header2.FRows) end else wo_EncRowSize := co_RowDef; (* Set alternative encoded block delimiter. *) if (paramcount = 5) then case pos(UpStr(paramstr(5)), co_AltDelStr) of 1 : SetAltDel(co_AltDelSet[1]); 4 : SetAltDel(co_AltDelSet[2]); 7 : SetAltDel(co_AltDelSet[3]); 10 : SetAltDel(co_AltDelSet[4]); 13 : SetAltDel(co_AltDelSet[5]); 16 : SetAltDel(co_AltDelSet[6]); 19 : SetAltDel(co_AltDelSet[7]); 22 : SetAltDel(co_AltDelSet[8]); 25 : SetAltDel(co_AltDelSet[9]); else Syntax end end end; (* ProcessParams. *) (***** Check if a file exists. *) (* *) function FileExist({input} st_Path : pathstr) : {output} boolean; begin FileExist := (FSearch(st_Path, '') <> '') end; (* FileExist. *) (***** Close file variable *only* if open. *) (* *) procedure CloseFile({update} var fi_IN); begin case filerec(fi_IN).mode of fminput, fmoutput, fminout : close(file(fi_IN)) end; if (ioresult <> 0) then halt(1) end; (* CloseFile. *) var wo_EncBlockNum : word; lo_FileTime : longint; st_NameOUT : namestr; st_ExtOUT : extstr; st_FilenameOUT : T_St12; fi_IN : file; fi_OUT : file; (***** Close all data files. *) (* *) procedure CloseDataFiles; begin (* Close input file. *) CloseFile(fi_IN); (* If not test-mode, then... *) if NOT bo_TestMode then begin (* If decoding and output file is not corrupt, then... *) if (NOT bo_Encoding) AND (NOT bo_EraseOutFile) then begin (* Set the output file date to the original binary file date. *) setftime(fi_OUT, lo_FileTime); if (doserror <> 0) then begin writeln(co_CrLf, 'ERROR SETTING DECODED FILE DATE ATTRIBUTE'); halt(1) end end; (* Close output file. *) CloseFile(fi_OUT); (* If output file is corrupt, then errase it. *) if bo_EraseOutFile then begin erase(fi_OUT); writeln(co_CrLf, 'OUTPUT FILE (', st_FilenameOUT, ') ERASED'); halt(1) end end end; (* CloseDataFiles. *) var bo_FileSizeFail : boolean; bo_FileDateFail : boolean; bo_BlockSizeFail : boolean; bo_FileNameFail : boolean; (***** Convert byte to block number string. *) (* *) function BlockNumStr({input } by_Block : byte) : {output} T_St2; var st_Num : T_St2; begin if bo_HexMode then BlockNumStr := Byte2Hex(by_Block) else begin str(by_Block, st_Num); BlockNumStr := st_Num end end; (* WriteBlockNum *) (***** Display error message. *) (* *) procedure ErrorMsg({input } const st_Path : pathstr; by_Block : byte; by_Lfeed : byte; in_Error : integer; bo_Halt : boolean); var by_Index : byte; begin for by_Index := 1 to by_Lfeed do writeln; case in_Error of 2 : writeln('FILE NOT FOUND ---> ', st_Path); 4 : writeln('TOO MANY FILES OPEN'); 5 : writeln('FILE ACCESS DENIED ---> ', st_Path); 15 : writeln('INVALID DRIVE ---> ', st_Path[1] + ':'); 100 : writeln('DISK ', st_Path[1], ': READ ERROR'); 101 : writeln('DISK ', st_Path[1], ': WRITE ERROR'); 150 : writeln('DISK ', st_Path[1], ': IS WRITE PROTECTED'); 152 : writeln('DRIVE ', st_Path[1], ': NOT READY'); 500 : writeln('ZERO BYTE FILE (CONTAINS NO DATA) ---> ', st_Path); 501 : writeln('FILE IS TOO LARGE TO ENCODE ---> ', st_Path); 502 : writeln('XX-BLOCK SIZE IS TOO SMALL TO ENCODE ---> ', st_Path); 503 : writeln('CANNOT OVERWRITE FILE TO ENCODE'); 504 : writeln('NOT ENOUGH FREE MEMORY'); 505 : writeln('XX34 HEADER ID NOT FOUND'); 506 : writeln('INVALID FILE SIZE ---> BLOCK ', BlockNumStr(by_Block)); 507 : writeln('BLOCK NUMBER GREATER THAN BLOCK TOTAL ---> BLOCK ', BlockNumStr(by_Block)); 508 : writeln('XX HEADER FILE SIZES DO NOT MATCH ---> BLOCK ', BlockNumStr(by_Block)); 509 : writeln('XX HEADER FILE DATES DO NOT MATCH ---> BLOCK ', BlockNumStr(by_Block)); 510 : writeln('XX HEADER COLUMN/ROW SIZES DO NOT MATCH ---> BLOCK ', BlockNumStr(by_Block)); 511 : writeln('XX HEADER FILE NAMES DO NOT MATCH ---> BLOCK ', BlockNumStr(by_Block)); 512 : writeln('CANNOT OVERWRITE FILE TO DECODE'); 513 : writeln('OUTPUT FILE IS READ-ONLY ---> ', st_Path); 514 : writeln('ERROR CONVERTING DATE-STRING TO DATE-RECORD FORMAT'); 515 : writeln('CRC FAILURE ---> BLOCK ', BlockNumStr(by_Block)) else writeln('DOS ERROR = ', in_Error) end; if bo_Halt then begin CloseDataFiles; halt(1) end end; (* ErrorMsg. *) var in_Error : integer; wo_EncBlockSize : word; wo_BinBlockSize : word; wo_EncBlockTotal : word; lo_FileSizeIN : longint; rc_FileDate : datetime; (***** Open input and output files. *) (* *) procedure OpenFiles; var st_Temp : T_St8; begin (* Check if input file exists. *) if FileExist(st_DirIN + st_NameIN + st_ExtIN) then assign(fi_IN, (st_DirIN + st_NameIN + st_ExtIN)) else ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, 2, true); (* Set TP's filemode variable to read-only. *) filemode := 0; (* Try to open the input file. *) reset(fi_IN, 1); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true); (* Record the input file size in bytes. *) lo_FileSizeIN := filesize(fi_IN); (* Check if input file is a "zero-byte" file. *) if (lo_FileSizeIN = 0) then ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, 500, true); (* If encoding, then... *) if bo_Encoding then begin (* Check if input file is too big to encode. *) if (lo_FileSizeIN > co_MaxFileSize) then ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, 501, true); (* Calculate encoded block size. *) wo_EncBlockSize := wo_EncColSize * pred(wo_EncRowSize); (* Calculate binary block size. *) wo_BinBlockSize := (wo_EncBlockSize div 4) * 3; (* Calculate total number of encoded blocks required. *) wo_EncBlockTotal := (lo_FileSizeIN div wo_BinBlockSize); if ((lo_FileSizeIN mod wo_BinBlockSize) <> 0) then inc(wo_EncBlockTotal); (* If encoded block total is equal to one, do not split output. *) if (wo_EncBlockTotal = 1) then bo_SplitOutput := false; (* If binary block size is too small to encode the input file. *) if (wo_EncBlockTotal > co_BlockMax) then ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, 502, true); (* Set hex-mode flag if block total is greater than 99, or if *) (* binary file size is greater than 999,999 bytes. *) bo_HexMode := (wo_EncBlockTotal > 99) OR (lo_FileSizeIN > 999999); (* If hex-mode, then set encoded block header hex-flag. *) if bo_HexMode then co_Header2.HexFlag := 'H'; (* Read input file date. *) getftime(fi_IN, lo_FileTime); in_Error := doserror; if (in_Error <> 0) then ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true); unpacktime(lo_FileTime, rc_FileDate); (* Assign input file date to the encoded header. *) with rc_FileDate do begin Long2Str(day, 2, co_Header2.Fday); Long2Str(month, 2, co_Header2.Fmonth); if (year < co_NextCentury) then dec(year, co_ThisCentury) else dec(year, co_NextCentury); Long2Str(year, 2, co_Header2.Fyear) end; (* Assign input file size to the encoded header. *) if bo_HexMode then begin st_Temp := Long2Hex(lo_FileSizeIN); delete(st_Temp, 1, 2); move(st_Temp[1], co_Header2.Size, 6) end else Long2Str(lo_FileSizeIN, 6, co_Header2.Size); (* Assign input filename to the encoded header. *) with co_Header2 do begin move(st_NameIN[1], Fname[9 - length(st_NameIN)], length(st_NameIN)); move(st_ExtIN[1], Fname[9], length(st_ExtIN)) end; (* Assign encoded block total to the encoded header. *) Word2Char2(wo_EncBlockTotal, co_Header2.BlockTot); (* Assign input file name to output file name. *) st_NameOUT := st_NameIN; (* Assign output file extension. *) if bo_SplitOutput then st_ExtOUT := '.X01' else st_ExtOUT := '.XX'; (* Assign output filename. *) assign(fi_OUT, (st_NameOUT + st_ExtOUT)); (* Check if output file already exists. *) if FileExist(st_NameOUT + st_ExtOUT) then begin (* File exists, is it OK to overwrite this file? *) write(co_CrLf, st_NameOUT + st_ExtOUT, ' already exists. Overwrite? [Y/N] '); case YesNoRename of (* No it's NOT OK to overwrite this file. STOP! *) 'N' : begin writeln(co_CrLf, 'ENCODING ABORTED'); CloseDataFiles; halt(0) end; (* Yes it's OK to overwrite this file. *) 'Y' : begin (* You cannot overwrite the file you want to encode. *) if ((st_NameIN + st_ExtIN) = (st_NameOUT + st_ExtOUT)) then ErrorMsg('', 0, 1, 503, true); (* Rewrite output file. *) rewrite(fi_OUT, 1); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true) end end end (* Else, the file does not exist. *) else begin (* Create the output file. *) rewrite(fi_OUT, 1); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true) end end end; (* OpenFiles. *) var wo_MaxBlockSize : word; wo_EncBuffSize : word; wo_BinBuffSize : word; po_HeapMark : pointer; po_EncBuff : T_EncBuffPtr; po_BinBuff : T_BinBuffPtr; (***** Create data buffers. *) (* *) procedure CreateBuffers; begin (* Determine buffer sizes. *) if bo_Encoding then (* Encoded block size + size of CrLf's + 128 for header/footer. *) wo_MaxBlockSize := wo_EncBlockSize + (wo_EncRowSize SHL 1) + 128; wo_EncBuffSize := wo_MaxBlockSize; wo_BinBuffSize := (wo_EncBuffSize SHR 2) * 3; (* Allocate buffers. *) mark(po_HeapMark); getmem(po_BinBuff, wo_BinBuffSize); if (po_BinBuff = NIL) then ErrorMsg('', 0, 1, 504, true); getmem(po_EncBuff, wo_EncBuffSize); if (po_EncBuff = NIL) then ErrorMsg('', 0, 1, 504, true) end; (* CreateBuffers. *) var wo_BytesIN : word; wo_BlockCount : word; wo_EncBuffOffset : word; wo_SkipIndex : word; (***** Set encoded block header. *) (* *) procedure SetEncHeader; begin (* Calculate and set the CRC-16 string for the encoded header. *) Long2Str(CalcCRC16(po_BinBuff^, wo_BytesIN), 5, co_Header2.CrcValue); (* Set the encoded block's block number. *) Word2Char2(wo_BlockCount, co_Header2.Block); (* Write encoded block header to encoding buffer. *) move(co_CrLf2, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_CrLf2)); inc(wo_EncBuffOffset, sizeof(co_CrLf2)); inc(wo_SkipIndex, sizeof(co_CrLf2)); move(co_Header2, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_Header2)); (* Advance the buffer index variables. *) inc(wo_EncBuffOffset, sizeof(co_Header2)); inc(wo_SkipIndex, sizeof(co_Header2)) end; (* SetEncHeader. *) (***** Set encoded block footer. *) (* *) procedure SetEncFooter; var ar_BlockNum : T_Ch2; begin (* Write encoded block footer to the encoding buffer. *) move(co_EndMark1, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_EndMark1)); inc(wo_EncBuffOffset, sizeof(co_EndMark1)); inc(wo_SkipIndex, sizeof(co_EndMark1)); move(co_EndMark2, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_EndMark2)); inc(wo_EncBuffOffset, sizeof(co_EndMark2)); inc(wo_SkipIndex, sizeof(co_EndMark2)); Word2Char1(wo_BlockCount, ar_BlockNum); move(ar_BlockNum, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(ar_BlockNum)); inc(wo_EncBuffOffset, sizeof(ar_BlockNum)); inc(wo_SkipIndex, sizeof(ar_BlockNum)); if bo_HexMode then begin if (po_EncBuff^[wo_EncBuffOffset] = #32) then po_EncBuff^[wo_EncBuffOffset] := 'h' else begin po_EncBuff^[succ(wo_EncBuffOffset)] := 'h'; inc(wo_EncBuffOffset); inc(wo_SkipIndex) end end; if (po_EncBuff^[wo_EncBuffOffset] <> #32) then begin po_EncBuff^[succ(wo_EncBuffOffset)] := #32; inc(wo_EncBuffOffset); inc(wo_SkipIndex) end; move(co_EndMark1, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_EndMark1)); inc(wo_EncBuffOffset, sizeof(co_EndMark1)); inc(wo_SkipIndex, sizeof(co_EndMark1)); move(co_CrLf2, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_CrLf2)); inc(wo_EncBuffOffset, sizeof(co_CrLf2)); inc(wo_SkipIndex, sizeof(co_CrLf2)) end; (* SetEncFooter. *) (***** Open new output file. *) (* *) procedure OpenNewFile; var st_Temp : T_St3; begin (* Close output file. *) close(fi_OUT); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true); (* Create new ouput file extension. *) st_Temp := BlockNumStr(lo(wo_BlockCount)); move(st_Temp[1], st_ExtOUT[5 - length(st_Temp)], length(st_Temp)); (* Open new output file. *) assign(fi_OUT, (st_NameOUT + st_ExtOUT)); rewrite(fi_OUT, 1); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true) end; (* OpenNewFile. *) var wo_BytesOUT : word; wo_BinBuffOffset : word; (***** Encode binary file. *) (* *) procedure Encode34; var lo_BytesEncoded : longint; begin CreateBuffers; (* Display encoding message. *) writeln(co_CrLf, 'ENCODING BLOCK'); (* Initialize variables. *) wo_BlockCount := 0; lo_BytesEncoded := 0; (* Repeat until entire binary file has been encoded. *) repeat wo_SkipIndex := 0; wo_BinBuffOffset := 0; wo_EncBuffOffset := 0; (* Clear the data buffers. *) fillchar(po_BinBuff^, wo_BinBuffSize, 0); fillchar(po_EncBuff^, wo_EncBuffSize, 0); (* Fill the input buffer. *) blockread(fi_IN, po_BinBuff^, wo_BinBlockSize, wo_BytesIN); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_NameIN + st_ExtIN), 0, 1, in_Error, true); (* Ensure the number of bytes to encode is a multiple of 3. *) if ((wo_BytesIN mod 3) <> 0) then wo_BytesIN := succ(wo_BytesIN div 3) * 3; (* Advance encoded block counter. *) inc(wo_BlockCount); (* Display block number being encoded. *) write(BlockNumStr(lo(wo_BlockCount)):4); (* Write encoded block header to output buffer. *) SetEncHeader; repeat (* Until all bytes in the input buffer are processed. *) (* Encode 3 input bytes into 4 encoded XX output characters. *) po_EncBuff^[succ(wo_EncBuffOffset)] := co_XxChar1[(po_BinBuff^[succ(wo_BinBuffOffset)] SHR 2)]; po_EncBuff^[wo_EncBuffOffset + 2] := co_XxChar1[((po_BinBuff^[succ(wo_BinBuffOffset)] AND 3) SHL 4) OR (po_BinBuff^[wo_BinBuffOffset + 2] SHR 4)]; po_EncBuff^[wo_EncBuffOffset + 3] := co_XxChar1[((po_BinBuff^[wo_BinBuffOffset + 2] AND 15) SHL 2) OR (po_BinBuff^[wo_BinBuffOffset + 3] SHR 6)]; po_EncBuff^[wo_EncBuffOffset + 4] := co_XxChar1[(po_BinBuff^[wo_BinBuffOffset + 3] AND 63)]; (* Advance the buffer indexes. *) inc(wo_BinBuffOffset, 3); inc(wo_EncBuffOffset, 4); (* If encoded character row is complete, then... *) if (((wo_EncBuffOffset - wo_SkipIndex) mod wo_EncColSize) = 0) then begin (* Add a CrLf to the encoded buffer. *) move(co_CrLf, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_CrLf)); (* Advance the buffer indexes. *) inc(wo_EncBuffOffset, sizeof(co_CrLf)); inc(wo_SkipIndex, sizeof(co_CrLf)) end (* Until all bytes in the input buffer are processed. *) until (wo_BinBuffOffset >= wo_BytesIN); (* If the last line of encoded output is not complete,then... *) if (((wo_EncBuffOffset - wo_SkipIndex) mod wo_EncColSize) <> 0) then begin (* Add a CrLf to the encoding buffer. *) move(co_CrLf, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_CrLf)); (* Advance the buffer indexes. *) inc(wo_EncBuffOffset, sizeof(co_CrLf)); inc(wo_SkipIndex, sizeof(co_CrLf)) end; (* Write encoded block footer to the output buffer. *) SetEncFooter; (* If encoded output is split, then... *) if bo_SplitOutput AND (wo_BlockCount > 1) then OpenNewFile; (* Write encoded buffer to output file. *) blockwrite(fi_OUT, po_EncBuff^, wo_EncBuffOffset, wo_BytesOUT); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true); inc(lo_BytesEncoded, wo_BinBuffOffset) until (lo_BytesEncoded >= lo_FileSizeIN); (* Release heap memory used. *) release(po_HeapMark); writeln end; (* Encode34. *) var wo_ScanPos : word; (***** Scan input file for encoded block identifier. *) (* *) procedure ScanForXxID; var wo_Index : word; begin (* Display scanning message. *) write(co_CrLf, 'SCANNING FOR BLOCK IDENTIFIER'); (* Calculate buffer size. *) if (lo_FileSizeIN < (60 * 1024)) then wo_EncBuffSize := lo_FileSizeIN else wo_EncBuffSize := 60 * 1024; (* Create scan buffer. *) mark(po_HeapMark); getmem(po_EncBuff, wo_EncBuffSize); if (po_EncBuff = NIL) then ErrorMsg('', 0, 2, 504, true); (* Clear scan buffer. *) fillchar(po_EncBuff^, wo_EncBuffSize, 0); (* Load the scan buffer. *) blockread(fi_IN, po_EncBuff^, wo_EncBuffSize, wo_BytesIN); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true); (* Search for encoded block ID. *) wo_Index := 1; repeat wo_ScanPos := PosSearch(po_EncBuff^, wo_EncBuffSize, co_XxBlockID); (* If encoded block ID was not found, then... *) if (wo_ScanPos = 0) then begin (* If all 10 ID delimiters were tried, and version number = '2' *) if (wo_Index = 10) AND (co_XxBlockID[7] = '2') then begin (* Set version number to '1'. *) co_XxBlockID[7] := '1'; (* Reset loop variable. *) wo_Index := 0 end; (* Set new block ID delimiter. *) if (wo_Index < 10) then co_XxBlockID[1] := co_AltDelSet[wo_Index]; (* Advance loop variable. *) inc(wo_Index) end until (wo_ScanPos <> 0) OR (wo_Index = 11); (* If block ID was not found, then... *) if (wo_ScanPos = 0) then begin writeln; ErrorMsg('', 0, 1, 505, true) end else writeln(' OK') end; (* ScanForXxID. *) var lo_EncFileOffset : longint; lo_FileSizeOUT : longint; ar_BinFileDate : T_3Ch2; ar_Crc16 : T_Wo255; ar_EncBlockFound : T_By256; ar_EncBlockPos : T_Lo255; ar_BinBlockSize : T_Wo255; ar_PhysBlockSize : T_Lo255; (***** Scan for all encoded block headers. *) (* *) procedure ScanForXxHeaders; var wo_Index, wo_TempColSize, wo_TempRowSize, wo_TempBlockNum, wo_TempBlockSize, wo_TempBlockTotal : word; lo_Temp, lo_TempFileSize : longint; ar_TempFileDate : T_3Ch2; st_TempOutName : T_St12; begin (* Display new message. *) write('SCANNING FOR BLOCK HEADERS'); bo_FileSizeFail := false; bo_FileDateFail := false; bo_BlockSizeFail := false; bo_FileNameFail := false; wo_EncBuffOffset := 0; wo_BlockCount := 0; lo_EncFileOffset := 0; fillchar(ar_EncBlockFound, sizeof(ar_EncBlockFound), 0); fillchar(ar_Crc16, sizeof(ar_Crc16), 0); fillchar(ar_EncBlockPos, sizeof(ar_EncBlockPos), 0); fillchar(ar_BinBlockSize, sizeof(ar_BinBlockSize), 0); fillchar(ar_PhysBlockSize, sizeof(ar_PhysBlockSize), 0); (* Repeat until the entire input file has been scanned. *) repeat (* Determine XX34 header position in the encoded buffer. *) wo_ScanPos := PosSearch(po_EncBuff^[succ(wo_EncBuffOffset)], (wo_BytesIN - (wo_EncBuffOffset + co_HeaderSize)), co_XxBlockID); (* If an encoded header was found, then... *) if (wo_ScanPos <> 0) then begin (* Record encoded header position, and advance block count. *) inc(wo_EncBuffOffset, wo_ScanPos); inc(wo_BlockCount); (* Clear the initialed encoded header variable. *) fillchar(co_Header1, sizeof(co_Header1), 0); (* Copy the encoded header found to the header variable. *) move(po_EncBuff^[wo_EncBuffOffset], co_Header1, sizeof(co_Header1)); (* Process encoded header data. *) with co_Header2 do begin bo_HexMode := (HexFlag = 'H'); lo_TempFileSize := Str2Long(Size, bo_HexMode); if (lo_TempFileSize = co_NumError) or (lo_TempFileSize < 1) then ErrorMsg('', lo(wo_BlockCount), 2, 506, true); ar_TempFileDate[1] := Fday; ar_TempFileDate[2] := Fmonth; ar_TempFileDate[3] := Fyear; wo_TempColSize := Str2Long(FCols, false); wo_TempRowSize := Str2Long(FRows, false); st_TempOutName := Fname; wo_TempBlockNum := Str2Long(Block, bo_HexMode); wo_TempBlockTotal := Str2Long(BlockTot, bo_HexMode); ar_Crc16[wo_TempBlockNum] := Str2Long(CrcValue, false) end; (* Check if block number from the encoded header is valid. *) if (wo_TempBlockNum > wo_TempBlockTotal) then ErrorMsg('', lo(wo_BlockCount), 2, 507, true); (* Record encoded block number found. *) inc(ar_EncBlockFound[wo_TempBlockNum]); (* Assign the encoded block file position. *) if (ar_EncBlockPos[wo_TempBlockNum] = 0) then inc(ar_EncBlockPos[wo_TempBlockNum], wo_EncBuffOffset); if (lo_EncFileOffset <> 0) then inc(ar_EncBlockPos[wo_TempBlockNum], lo_EncFileOffset); (* Calculate temp encoded block size. *) wo_TempBlockSize := pred(wo_TempRowSize) * (wo_TempColSize + 2); (* Record temp encoded block size. *) ar_BinBlockSize[wo_TempBlockNum] := (((wo_TempColSize * pred(wo_TempRowSize)) SHR 2) * 3); (* If this is physically the first encoded block, record the *) (* encoded block values. *) if (wo_BlockCount = 1 ) then begin lo_FileSizeOUT := lo_TempFileSize; ar_BinFileDate := ar_TempFileDate; wo_EncRowSize := wo_TempRowSize; wo_EncBlockSize := wo_TempBlockSize; st_FilenameOUT := st_TempOutName; wo_EncBlockTotal := wo_TempBlockTotal end (* Else, this is not the first block found, check for errors. *) else begin if (lo_TempFileSize <> lo_FileSizeOUT) AND (bo_FileSizeFail = false) then byte(bo_FileSizeFail) := wo_TempBlockNum; if (T_Ch6(ar_TempFileDate) <> T_Ch6(ar_BinFileDate)) AND (bo_FileDateFail = false) then byte(bo_FileDateFail) := wo_TempBlockNum; if (wo_TempBlockSize <> wo_EncBlockSize) AND (bo_BlockSizeFail = false) then byte(bo_BlockSizeFail) := wo_TempBlockNum; If (st_TempOutName <> st_FilenameOUT) AND (bo_FileNameFail = false) then byte(bo_FileNameFail) := wo_TempBlockNum end; (* Advance the encoded buffer index. *) if (wo_EncBuffOffset < (wo_BytesIN - co_HeaderSize)) then inc(wo_EncBuffOffset, co_HeaderSize) end (* Else, no additional encoded headers were found. *) else begin (* Advance the input file offset. *) inc(lo_EncFileOffset, (wo_BytesIN - co_HeaderSize)); (* If input file not completely scanned, then reload buffer. *) if ((lo_EncFileOffset + co_HeaderSize) < lo_FileSizeIN) then begin (* Reset control variables. *) wo_EncBuffOffset := 0; (* Clear scan buffer. *) fillchar(po_EncBuff^, wo_EncBuffSize, 0); (* Reset input file pointer. *) seek(fi_IN, lo_EncFileOffset); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_NameIN + st_ExtIN), 0, 1, in_Error, true); (* Load the scan buffer. *) blockread(fi_IN, po_EncBuff^, wo_EncBuffSize, wo_BytesIN); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_NameIN + st_ExtIN), 0, 1, in_Error, true) end end (* Until the entire input file has been scanned. *) until (lo_EncFileOffset + co_HeaderSize) > pred(lo_FileSizeIN); (* Release heap memory used. *) release(po_HeapMark); writeln(' OK'); (* Encoded block size + 2x CrLF size + 128 for header/footer. *) wo_MaxBlockSize := wo_EncBlockSize + (wo_EncRowSize SHL 2) + 128; (* Set the maximum physical size for encoded blocks. *) for wo_Index := 1 to wo_EncBlockTotal do if (ar_EncBlockFound[wo_Index] = 1) then ar_PhysBlockSize[wo_Index] := wo_MaxBlockSize; (* Calculate binary size of last encoded block. *) wo_Index := 1; while (ar_EncBlockFound[wo_Index] <> 1) and (wo_Index < wo_EncBlockTotal) do inc(wo_Index); lo_Temp := lo_FileSizeOUT - (longint(ar_BinBlockSize[wo_Index]) * pred(wo_EncBlockTotal)); if (lo_Temp < ar_BinBlockSize[wo_Index]) then begin ar_BinBlockSize[wo_EncBlockTotal] := lo_Temp; ar_PhysBlockSize[wo_EncBlockTotal] := ((lo_Temp div 3) SHL 2) + (wo_EncRowSize SHL 2) end end; (* ScanForXxHeaders. *) (***** Check for encoded block errors. *) (* *) procedure CheckForXxErrors; var wo_Index : word; begin (* Display error checking message. *) write('CHECKING FOR BLOCK ERRORS'); (* Check for encoded block data errors. *) if bo_FileSizeFail then ErrorMsg('', byte(bo_FileSizeFail), 2, 508, true); if bo_FileDateFail then ErrorMsg('', byte(bo_FileDateFail), 2, 509, true); if bo_BlockSizeFail then ErrorMsg('', byte(bo_BlockSizeFail), 2, 510, true); if bo_FileNameFail then ErrorMsg('', byte(bo_FileNameFail), 2, 511, true); (* Check for duplicate/missing encoded blocks. *) for wo_Index := 1 to wo_EncBlockTotal do if (ar_EncBlockFound[wo_Index] <> 1) then inc(ar_EncBlockFound[0]); (* If a duplicate/missing encoded block found, then... *) if (ar_EncBlockFound[0] <> 0) then begin writeln(' FAIL'); writeln; for wo_Index := 1 to wo_EncBlockTotal do if (ar_EncBlockFound[wo_Index] > 1) then writeln('DUPLICATE BLOCK ', BlockNumStr(lo(wo_Index))) else if (ar_EncBlockFound[wo_Index] = 0) then writeln(' MISSING BLOCK ', BlockNumStr(lo(wo_Index))); if NOT bo_TestMode then begin CloseDataFiles; halt(1) end end else writeln(' OK') end; (* CheckForXxErrors. *) (***** Remove '-' chars from filename. *) (* *) procedure CleanFileName; begin while (st_FilenameOUT[1] = '-') do delete(st_FilenameOUT, 1, 1); while (st_FilenameOUT[length(st_FilenameOUT)] = '-') do delete(st_FilenameOUT, length(st_FilenameOUT), 1) end; (* CleanFileName. *) (***** Prepare the output file for the decoded binary data. *) (* *) procedure CheckOutputFile; label CheckAgain; var wo_FileAttr : word; begin (* Assign the output file name. *) assign(fi_OUT, st_FilenameOUT); (* Check if binary output file already exists. *) if FileExist(st_FilenameOUT) then begin CheckAgain: (* Check to see if it's OK to over-write this file. *) write(co_CrLf, st_FilenameOUT,' already exists. Overwrite? [Y/N/R] '); case YesNoRename of (* NO it's NOT OK to overwrite this file. STOP! *) 'N' : begin writeln(co_CrLf, 'DECODING ABORTED'); CloseDataFiles; halt(0) end; (* Rename output filename. *) 'R' : begin write('New output name? '); st_FilenameOUT := EnterFilename; writeln; (* If new name exists too, then start over. *) if FileExist(st_FilenameOUT) then goto CheckAgain; (* Create new output file. *) assign(fi_Out, st_FilenameOUT); rewrite(fi_OUT, 1); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true) end; (* Yes it's OK to overwrite file. *) 'Y' : begin (* You cannot overwrite the file you want to decode. *) if ((st_NameIN + st_ExtIN) = st_FilenameOUT) then ErrorMsg('', 0, 1, 512, true); (* Check to see if the output file is 'READ-ONLY'. *) getfattr(fi_OUT, wo_FileAttr); in_Error := doserror; if (in_Error <> 0) then ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true); if ((wo_FileAttr AND 1) <> 0) then ErrorMsg(fexpand(st_FilenameOUT), 0, 1, 513, true); (* Create new output file. *) rewrite(fi_OUT, 1); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true) end end end (* Else the file does not exist, create it. *) else begin rewrite(fi_OUT, 1); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true) end end; (* CheckOutputFile. *) (***** Set the file date for the output file. *) (* *) procedure PrepareFileDate; var in_Error : integer; begin (* Determine original binary file date from XxHeader *) with rc_FileDate do begin val(ar_BinFileDate[3], year, in_Error); if (in_Error <> 0) then ErrorMsg('', 0, 1, 514, true); inc(year, co_ThisCentury); val(ar_BinFileDate[2], month, in_Error); if (in_Error <> 0) then ErrorMsg('', 0, 1, 514, true); val(ar_BinFileDate[1], day, in_Error); if (in_Error <> 0) then ErrorMsg('', 0, 1, 514, true); hour := 0; min := 0; sec := 0 end; packtime(rc_FileDate, lo_FileTime) end; (* PrepareFileDate. *) (***** Decode/Test the encoded input file. *) (* *) procedure Decode43; var lo_BytesDecoded : longint; begin ScanForXxID; ScanForXxHeaders; CheckForXxErrors; if NOT bo_TestMode then begin CleanFileName; CheckOutputFile; PrepareFileDate end; (* Display testing/decoding message. *) if bo_TestMode then writeln(co_CrLf, 'TESTING BLOCK') else writeln(co_CrLf, 'DECODING BLOCK'); (* Initialize variables. *) wo_BytesOUT := 0; wo_EncBlockNum := 0; lo_BytesDecoded := 0; lo_EncFileOffset := 0; CreateBuffers; repeat (* Until the original binary file has been completely re-built. *) (* Advance the encoded block number to read into the buffer. *) inc(wo_EncBlockNum); (* Advance the block number until an encoded block is found, *) (* and block number is less than the encoded the block total. *) while (ar_EncBlockFound[wo_EncBlockNum] <> 1) and (wo_EncBlockNum < wo_EncBlockTotal) do inc(wo_EncBlockNum); (* If a valid block exists, then... *) if (ar_EncBlockFound[wo_EncBlockNum] = 1) then begin (* Initialize the buffer variables. *) wo_BinBuffOffset := 0; wo_EncBuffOffset := co_HeaderSize; (* Clear binary buffer. *) fillchar(po_BinBuff^, wo_BinBuffSize, 0); (* Clear encoded buffer. *) fillchar(po_EncBuff^, wo_EncBuffSize, 0); (* Position input file pointer. *) seek(fi_IN, pred(ar_EncBlockPos[wo_EncBlockNum])); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true); (* Load encoded block into buffer. *) blockread(fi_IN, po_EncBuff^, ar_PhysBlockSize[wo_EncBlockNum], wo_BytesIN); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true); (* Display encoded block number. *) write(BlockNumStr(lo(wo_EncBlockNum)):4); (* Until entire encoded block is decoded. *) repeat (* Advance encoded buffer offset, while character is not in the *) (* XX character set. *) while NOT (po_EncBuff^[succ(wo_EncBuffOffset)] IN co_XxChar2) do inc(wo_EncBuffOffset); (* Decode 4 encoded chars into 3 binary bytes. *) po_BinBuff^[succ(wo_BinBuffOffset)] := (co_BinTable[ord(po_EncBuff^[succ(wo_EncBuffOffset)])] SHL 2) OR (co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 2)])] SHR 4); po_BinBuff^[wo_BinBuffOffset + 2] := ((co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 2)])] AND 15) SHL 4) OR (co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 3)])] SHR 2); po_BinBuff^[wo_BinBuffOffset + 3] := ((co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 3)])] AND 3) SHL 6) OR (co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 4)])] AND 63); (* Advance buffer indexes. *) inc(wo_EncBuffOffset, 4); inc(wo_BinBuffOffset, 3) (* Until encoded block is completely decoded. *) until (wo_BinBuffOffset > pred(ar_BinBlockSize[wo_EncBlockNum])); (* Compare new CRC value with encoded block header CRC value. *) if (CalcCRC16(po_BinBuff^, wo_BinBuffOffset) <> ar_Crc16[wo_EncBlockNum]) then begin if NOT bo_TestMode then begin bo_EraseOutFile := true; ErrorMsg('', lo(wo_EncBlockNum), 2, 515, true) end else writeln(' CRC FAILED') end else if bo_TestMode then writeln(' CRC OK'); (* Write the decoded binary bytes to disk. *) if NOT bo_TestMode then begin blockwrite(fi_OUT, po_BinBuff^, ar_BinBlockSize[wo_EncBlockNum], wo_BytesOUT); in_Error := ioresult; if (in_Error <> 0) then ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true); (* Advance the binary bytes decoded count. *) inc(lo_BytesDecoded, wo_BytesOUT) end end; (* If in "test mode", and last encoded block has been tested, *) (* then break repeat until loop. *) if bo_TestMode AND (wo_EncBlockNum = wo_EncBlockTotal) then break (* Until original binary file has been rebuilt. *) until (lo_BytesDecoded > pred(lo_FileSizeOUT)); (* Return buffer memory to the heap. *) release(po_HeapMark); if NOT bo_TestMode then writeln end; (* Decode43. *) (***** Custom heap error function. Returns NIL pointer if error occurs. *) (* *) function CustHeapError({input} wo_Size : word) : {output} integer; far; begin CustHeapError := 1 end; (* CustHeapError. *) BEGIN (* Install custom heap error function. *) HeapError := addr(CustHeapError); ProcessParams; OpenFiles; if bo_Encoding then Encode34 else Decode43; CloseDataFiles END.